home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / boot / sort.pl < prev    next >
Encoding:
Text File  |  1995-06-14  |  2.8 KB  |  120 lines
  1. /*  $Id: sort.pl,v 1.2 1995/06/14 08:21:23 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: keysort and predsort
  7. */
  8.  
  9. :- module($sort,
  10.     [ keysort/2
  11.     , predsort/3
  12.     , merge/3
  13.     , merge_set/3
  14.     ]).
  15.  
  16. %   merge_set(+Set1, +Set2, -Set3)
  17. %   Merge the ordered sets Set1 and Set2 into a new ordered set without
  18. %   duplicates.
  19.  
  20. merge_set([], L, L) :- !.
  21. merge_set(L, [], L) :- !.
  22. merge_set([H1|T1], [H2|T2], [H1|R]) :- H1 @< H2, !, merge_set(T1, [H2|T2], R).
  23. merge_set([H1|T1], [H2|T2], [H2|R]) :- H1 @> H2, !, merge_set([H1|T1], T2, R).
  24. merge_set([H1|T1], [H2|T2], [H1|R]) :- H1 == H2,    merge_set(T1, T2, R).
  25.  
  26. %    merge(+List1, +List2, -List3)
  27. %    Merge the ordered sets List1 and List2 into a new ordered  list.
  28. %    Duplicates are not removed and their order is maintained.
  29.  
  30. merge([], L, L) :- !.
  31. merge(L, [], L) :- !.
  32. merge([H1|T1], [H2|T2], [H|R]) :-
  33.     (   H1 @=< H2
  34.     ->  H = H1,
  35.         merge(T1, [H2|T2], R)
  36.     ;   H = H2,
  37.         merge([H1|T1], T2, R)
  38.     ).
  39.  
  40. %    keysort(+Random, ?Ordered)
  41. %    Sorts a random list of Key-Value pairs, and does not remove duplicates.
  42.  
  43. keysort(List, Sorted) :-
  44.     length(List, Length), 
  45.     $keysort(Length, List, _, Result), 
  46.     Sorted = Result.
  47.  
  48. $keysort(2, [X1, X2|L], L, R) :- !, 
  49.     X1 = K1-_,
  50.     X2 = K2-_,
  51.     (   K1 @=< K2
  52.     ->  R = [X1, X2]
  53.     ;   R = [X2, X1]
  54.     ).
  55. $keysort(1, [X|L], L, [X]) :- !.
  56. $keysort(0, L, L, []) :- !.
  57. $keysort(N, L1, L3, R) :-
  58.     N1 is N // 2, 
  59.     N2 is N - N1, 
  60.     $keysort(N1, L1, L2, R1), 
  61.     $keysort(N2, L2, L3, R2), 
  62.     $keymerge(R1, R2, R).
  63.  
  64. $keymerge([], R, R) :- !.
  65. $keymerge(R, [], R) :- !.
  66. $keymerge(R1, R2, [X|R]) :-
  67.     R1 = [X1|R1a], 
  68.     R2 = [X2|R2a], 
  69.     X1 = K1-_,
  70.     X2 = K2-_,
  71.     (   K1 @> K2
  72.     ->  X = X2, $keymerge(R1, R2a, R)
  73.     ;   X = X1, $keymerge(R1a, R2, R)
  74.     ).
  75.  
  76. :- module_transparent
  77.     predsort/3, 
  78.     $predsort/5, 
  79.     $predmerge/4, 
  80.     $predmerge/7, 
  81.     $predcompare/4.
  82.  
  83. /*  Predicate based sort. This one is not copied.
  84.  
  85.  ** Sun Jun  5 16:13:38 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  86.  
  87. predsort(P, L, R) :-
  88.     length(L, N), 
  89.     $predsort(P, N, L, _, R1), !, 
  90.     R = R1.
  91.  
  92. $predsort(P, 2, [X1, X2|L], L, R) :- !, 
  93.     $predcompare(P, Delta, X1, X2), 
  94.     (   Delta = (>),  R = [X2, X1]
  95.     ;                 R = [X1, X2]
  96.     ), !.
  97. $predsort(_, 1, [X|L], L, [X]) :- !.
  98. $predsort(_, 0, L, L, []) :- !.
  99. $predsort(P, N, L1, L3, R) :-
  100.     N1 is N // 2, 
  101.     plus(N1, N2, N), 
  102.     $predsort(P, N1, L1, L2, R1), 
  103.     $predsort(P, N2, L2, L3, R2), 
  104.     $predmerge(P, R1, R2, R).
  105.  
  106. $predmerge(_, [], R, R) :- !.
  107. $predmerge(_, R, [], R) :- !.
  108. $predmerge(P, [H1|T1], [H2|T2], Result) :-
  109.     $predcompare(P, Delta, H1, H2), 
  110.     $predmerge(Delta, P, H1, H2, T1, T2, Result).
  111.  
  112. $predmerge((>), P, H1, H2, T1, T2, [H2|R]) :- !,
  113.     $predmerge(P, [H1|T1], T2, R).
  114. $predmerge(_, P, H1, H2, T1, T2, [H1|R]) :-
  115.     $predmerge(P, T1, [H2|T2], R).
  116.  
  117. $predcompare(P, (>), A, B) :-
  118.     call(P, B, A), !.
  119. $predcompare(_, (<), _, _).
  120.